home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / ice-9 / debugger.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  5.0 KB  |  147 lines
  1. ;;;; Guile Debugger
  2.  
  3. ;;; Copyright (C) 1999, 2001, 2002, 2006 Free Software Foundation, Inc.
  4. ;;;
  5. ;; This library is free software; you can redistribute it and/or
  6. ;; modify it under the terms of the GNU Lesser General Public
  7. ;; License as published by the Free Software Foundation; either
  8. ;; version 2.1 of the License, or (at your option) any later version.
  9. ;; 
  10. ;; This library is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13. ;; Lesser General Public License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Lesser General Public
  16. ;; License along with this library; if not, write to the Free Software
  17. ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18.  
  19. (define-module (ice-9 debugger)
  20.   #:use-module (ice-9 debugger command-loop)
  21.   #:use-module (ice-9 debugger state)
  22.   #:use-module (ice-9 debugger utils)
  23.   #:use-module (ice-9 format)
  24.   #:export (debug-stack
  25.         debug
  26.         debug-last-error
  27.         debugger-error
  28.         debugger-quit
  29.         debugger-input-port
  30.         debugger-output-port
  31.         debug-on-error)
  32.   #:no-backtrace)
  33.  
  34. ;;; The old (ice-9 debugger) has been factored into its constituent
  35. ;;; parts:
  36. ;;;
  37. ;;; (ice-9 debugger) - public interface to all of the following
  38. ;;;
  39. ;;; (... commands) - procedures implementing the guts of the commands
  40. ;;;                  provided by the interactive debugger
  41. ;;;
  42. ;;; (... command-loop) - binding these commands into the interactive
  43. ;;;                      debugger command loop
  44. ;;;
  45. ;;; (... state) - implementation of an object that tracks current
  46. ;;;               debugger state
  47. ;;;
  48. ;;; (... utils) - utilities for printing out frame and stack
  49. ;;;               information in various formats
  50. ;;;
  51. ;;; The division between (... commands) and (... command-loop) exists
  52. ;;; because I (NJ) have another generic command loop implementation
  53. ;;; under development, and I want to be able to switch easily between
  54. ;;; that and the command loop implementation here.  Thus the
  55. ;;; procedures in this file delegate to a debugger command loop
  56. ;;; implementation via the `debugger-command-loop-*' interface.  The
  57. ;;; (ice-9 debugger command-loop) implementation can be replaced by
  58. ;;; any other that implements the `debugger-command-loop-*' interface
  59. ;;; simply by changing the relevant #:use-module line above.
  60. ;;;
  61. ;;; - Neil Jerram <neil@ossau.uklinux.net> 2002-10-26, updated 2005-07-09
  62.  
  63. (define *not-yet-introduced* #t)
  64.  
  65. (define (debug-stack stack . flags)
  66.   "Invoke the Guile debugger to explore the specified @var{stack}.
  67.  
  68. @var{flags}, if present, are keywords indicating characteristics of
  69. the debugging session: the valid keywords are as follows.
  70.  
  71. @table @code
  72. @item #:continuable
  73. Indicates that the debugger is being invoked from a context (such as
  74. an evaluator trap handler) where it is possible to return from the
  75. debugger and continue normal code execution.  This enables the
  76. @dfn{continuing execution} commands, for example @code{continue} and
  77. @code{step}.
  78.  
  79. @item #:with-introduction
  80. Indicates that the debugger should display an introductory message.
  81. @end table"
  82.   (start-stack 'debugger
  83.     (let ((state (apply make-state stack 0 flags)))
  84.       (with-input-from-port (debugger-input-port)
  85.     (lambda ()
  86.       (with-output-to-port (debugger-output-port)
  87.         (lambda ()
  88.           (if (or *not-yet-introduced*
  89.               (memq #:with-introduction flags))
  90.           (let ((ssize (stack-length stack)))
  91.             (display "This is the Guile debugger -- for help, type `help'.\n")
  92.             (set! *not-yet-introduced* #f)
  93.             (if (= ssize 1)
  94.             (display "There is 1 frame on the stack.\n\n")
  95.             (format #t "There are ~A frames on the stack.\n\n" ssize))))
  96.           (write-state-short state)
  97.           (debugger-command-loop state))))))))
  98.  
  99. (define (debug)
  100.   "Invoke the Guile debugger to explore the context of the last error."
  101.   (let ((stack (fluid-ref the-last-stack)))
  102.     (if stack
  103.     (debug-stack stack)
  104.     (display "Nothing to debug.\n"))))
  105.  
  106. (define debug-last-error debug)
  107.  
  108. (define (debugger-error message)
  109.   "Signal a debugger usage error with message @var{message}."
  110.   (debugger-command-loop-error message))
  111.  
  112. (define (debugger-quit)
  113.   "Exit the debugger."
  114.   (debugger-command-loop-quit))
  115.  
  116. ;;; {Debugger Input and Output Ports}
  117.  
  118. (define debugger-input-port
  119.   (let ((input-port (current-input-port)))
  120.     (make-procedure-with-setter
  121.      (lambda () input-port)
  122.      (lambda (port) (set! input-port port)))))
  123.  
  124. (define debugger-output-port
  125.   (let ((output-port (current-output-port)))
  126.     (make-procedure-with-setter
  127.      (lambda () output-port)
  128.      (lambda (port) (set! output-port port)))))
  129.  
  130. ;;; {Debug on Error}
  131.  
  132. (define (debug-on-error syms)
  133.   "Enable or disable debug on error."
  134.   (set! lazy-handler-dispatch
  135.     (if syms
  136.         (lambda (key . args)
  137.           (if (memq key syms)
  138.           (begin
  139.             (debug-stack (make-stack #t lazy-handler-dispatch)
  140.                  #:with-introduction
  141.                  #:continuable)
  142.             (throw 'abort key)))
  143.           (apply default-lazy-handler key args))
  144.         default-lazy-handler)))
  145.  
  146. ;;; (ice-9 debugger) ends here.
  147.